home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xlcont.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  28KB  |  1,412 lines
  1. /* xlcont - xlisp special forms */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv,xldenv,xlvalue;
  10. extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
  11. extern LVAL s_svalue,s_sfunction,s_splist;
  12. extern LVAL s_lambda,s_macro;
  13. extern LVAL s_comma,s_comat;
  14. extern LVAL s_unbound;
  15. extern LVAL true;
  16.  
  17. /* external routines */
  18. extern LVAL makearglist();
  19.  
  20. /* forward declarations */
  21. FORWARD LVAL bquote1();
  22. FORWARD LVAL let();
  23. FORWARD LVAL flet();
  24. FORWARD LVAL prog();
  25. FORWARD LVAL progx();
  26. FORWARD LVAL doloop();
  27. FORWARD LVAL evarg();
  28. FORWARD LVAL match();
  29. FORWARD LVAL evmatch();
  30.  
  31. /* dummy node type for a list */
  32. #define LIST    -1
  33.  
  34. /* xquote - special form 'quote' */
  35. LVAL xquote()
  36. {
  37.     LVAL val;
  38.     val = xlgetarg();
  39.     xllastarg();
  40.     return (val);
  41. }
  42.  
  43. /* xfunction - special form 'function' */
  44. LVAL xfunction()
  45. {
  46.     LVAL val;
  47.  
  48.     /* get the argument */
  49.     val = xlgetarg();
  50.     xllastarg();
  51.  
  52.     /* create a closure for lambda expressions */
  53.     if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
  54.     val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
  55.  
  56.     /* otherwise, get the value of a symbol */
  57.     else if (symbolp(val))
  58.     val = xlgetfunction(val);
  59.  
  60.     /* otherwise, its an error */
  61.     else
  62.     xlerror("not a function",val);
  63.  
  64.     /* return the function */
  65.     return (val);
  66. }
  67.  
  68. /* xbquote - back quote special form */
  69. LVAL xbquote()
  70. {
  71.     LVAL expr;
  72.  
  73.     /* get the expression */
  74.     expr = xlgetarg();
  75.     xllastarg();
  76.  
  77.     /* fill in the template */
  78.     return (bquote1(expr));
  79. }
  80.  
  81. /* bquote1 - back quote helper function */
  82. LOCAL LVAL bquote1(expr)
  83.   LVAL expr;
  84. {
  85.     LVAL val,list,last,new;
  86.  
  87.     /* handle atoms */
  88.     if (atom(expr))
  89.     val = expr;
  90.  
  91.     /* handle (comma <expr>) */
  92.     else if (car(expr) == s_comma) {
  93.     if (atom(cdr(expr)))
  94.         xlfail("bad comma expression");
  95.     val = xleval(car(cdr(expr)));
  96.     }
  97.  
  98.     /* handle ((comma-at <expr>) ... ) */
  99.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  100.     xlstkcheck(2);
  101.     xlsave(list);
  102.     xlsave(val);
  103.     if (atom(cdr(car(expr))))
  104.         xlfail("bad comma-at expression");
  105.     list = xleval(car(cdr(car(expr))));
  106.     for (last = NIL; consp(list); list = cdr(list)) {
  107.         new = consa(car(list));
  108.         if (last)
  109.         rplacd(last,new);
  110.         else
  111.         val = new;
  112.         last = new;
  113.     }
  114.     if (last)
  115.         rplacd(last,bquote1(cdr(expr)));
  116.     else
  117.         val = bquote1(cdr(expr));
  118.     xlpopn(2);
  119.     }
  120.  
  121.     /* handle any other list */
  122.     else {
  123.     xlsave1(val);
  124.     val = consa(NIL);
  125.     rplaca(val,bquote1(car(expr)));
  126.     rplacd(val,bquote1(cdr(expr)));
  127.     xlpop();
  128.     }
  129.  
  130.     /* return the result */
  131.     return (val);
  132. }
  133.  
  134. /* xlambda - special form 'lambda' */
  135. LVAL xlambda()
  136. {
  137.     LVAL fargs,arglist,val;
  138.  
  139.     /* get the formal argument list and function body */
  140.     xlsave1(arglist);
  141.     fargs = xlgalist();
  142.     arglist = makearglist(xlargc,xlargv);
  143.  
  144.     /* create a new function definition */
  145.     val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);
  146.  
  147.     /* restore the stack and return the closure */
  148.     xlpop();
  149.     return (val);
  150. }
  151.  
  152. /* xgetlambda - get the lambda expression associated with a closure */
  153. LVAL xgetlambda()
  154. {
  155.     LVAL closure;
  156.     closure = xlgaclosure();
  157.     return (cons(gettype(closure),
  158.                  cons(getlambda(closure),getbody(closure))));
  159. }
  160.  
  161. /* xsetq - special form 'setq' */
  162. LVAL xsetq()
  163. {
  164.     LVAL sym,val;
  165.  
  166.     /* handle each pair of arguments */
  167.     for (val = NIL; moreargs(); ) {
  168.     sym = xlgasymbol();
  169.     val = xleval(nextarg());
  170.     xlsetvalue(sym,val);
  171.     }
  172.  
  173.     /* return the result value */
  174.     return (val);
  175. }
  176.  
  177. /* xpsetq - special form 'psetq' */
  178. LVAL xpsetq()
  179. {
  180.     LVAL plist,sym,val;
  181.  
  182.     /* protect some pointers */
  183.     xlsave1(plist);
  184.  
  185.     /* handle each pair of arguments */
  186.     for (val = NIL; moreargs(); ) {
  187.     sym = xlgasymbol();
  188.     val = xleval(nextarg());
  189.     plist = cons(cons(sym,val),plist);
  190.     }
  191.  
  192.     /* do parallel sets */
  193.     for (; plist; plist = cdr(plist))
  194.     xlsetvalue(car(car(plist)),cdr(car(plist)));
  195.  
  196.     /* restore the stack */
  197.     xlpop();
  198.  
  199.     /* return the result value */
  200.     return (val);
  201. }
  202.  
  203. /* xsetf - special form 'setf' */
  204. LVAL xsetf()
  205. {
  206.     LVAL place,value;
  207.  
  208.     /* protect some pointers */
  209.     xlsave1(value);
  210.  
  211.     /* handle each pair of arguments */
  212.     while (moreargs()) {
  213.  
  214.     /* get place and value */
  215.     place = xlgetarg();
  216.     value = xleval(nextarg());
  217.  
  218.     /* expand macros in the place form */
  219.     if (consp(place))
  220.         place = xlexpandmacros(place);
  221.     
  222.     /* check the place form */
  223.     if (symbolp(place))
  224.         xlsetvalue(place,value);
  225.     else if (consp(place))
  226.         placeform(place,value);
  227.     else
  228.         xlfail("bad place form");
  229.     }
  230.  
  231.     /* restore the stack */
  232.     xlpop();
  233.  
  234.     /* return the value */
  235.     return (value);
  236. }
  237.  
  238. /* placeform - handle a place form other than a symbol */
  239. LOCAL placeform(place,value)
  240.   LVAL place,value;
  241. {
  242.     LVAL fun,arg1,arg2;
  243.     int i;
  244.  
  245.     /* check the function name */
  246.     if ((fun = match(SYMBOL,&place)) == s_get) {
  247.     xlstkcheck(2);
  248.     xlsave(arg1);
  249.     xlsave(arg2);
  250.     arg1 = evmatch(SYMBOL,&place);
  251.     arg2 = evmatch(SYMBOL,&place);
  252.     if (place) toomany(place);
  253.     xlputprop(arg1,value,arg2);
  254.     xlpopn(2);
  255.     }
  256.     else if (fun == s_svalue) {
  257.     arg1 = evmatch(SYMBOL,&place);
  258.     if (place) toomany(place);
  259.     setvalue(arg1,value);
  260.     }
  261.     else if (fun == s_sfunction) {
  262.     arg1 = evmatch(SYMBOL,&place);
  263.     if (place) toomany(place);
  264.     setfunction(arg1,value);
  265.     }
  266.     else if (fun == s_splist) {
  267.     arg1 = evmatch(SYMBOL,&place);
  268.     if (place) toomany(place);
  269.     setplist(arg1,value);
  270.     }
  271.     else if (fun == s_car) {
  272.     arg1 = evmatch(CONS,&place);
  273.     if (place) toomany(place);
  274.     rplaca(arg1,value);
  275.     }
  276.     else if (fun == s_cdr) {
  277.     arg1 = evmatch(CONS,&place);
  278.     if (place) toomany(place);
  279.     rplacd(arg1,value);
  280.     }
  281.     else if (fun == s_nth) {
  282.     xlsave1(arg1);
  283.     arg1 = evmatch(FIXNUM,&place);
  284.     arg2 = evmatch(LIST,&place);
  285.     if (place) toomany(place);
  286.     for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
  287.         arg2 = cdr(arg2);
  288.     if (consp(arg2))
  289.         rplaca(arg2,value);
  290.     xlpop();
  291.     }
  292.     else if (fun == s_aref) {
  293.     xlsave1(arg1);
  294.     arg1 = evmatch(VECTOR,&place);
  295.     arg2 = evmatch(FIXNUM,&place); i = (int)getfixnum(arg2);
  296.     if (place) toomany(place);
  297.     if (i < 0 || i >= getsize(arg1))
  298.         xlerror("index out of range",arg2);
  299.     setelement(arg1,i,value);
  300.     xlpop();
  301.     }
  302.     else if (fun = xlgetprop(fun,s_setf))
  303.     setffunction(fun,place,value);
  304.     else
  305.     xlfail("bad place form");
  306. }
  307.  
  308. /* setffunction - call a user defined setf function */
  309. LOCAL setffunction(fun,place,value)
  310.   LVAL fun,place,value;
  311. {
  312.     LVAL *newfp;
  313.     int argc;
  314.  
  315.     /* create the new call frame */
  316.     newfp = xlsp;
  317.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  318.     pusharg(fun);
  319.     pusharg(NIL);
  320.  
  321.     /* push the values of all of the place expressions and the new value */
  322.     for (argc = 1; consp(place); place = cdr(place), ++argc)
  323.     pusharg(xleval(car(place)));
  324.     pusharg(value);
  325.  
  326.     /* insert the argument count and establish the call frame */
  327.     newfp[2] = cvfixnum((FIXTYPE)argc);
  328.     xlfp = newfp;
  329.  
  330.     /* apply the function */
  331.     xlapply(argc);
  332. }
  333.                
  334. /* xdefun - special form 'defun' */
  335. LVAL xdefun()
  336. {
  337.     LVAL sym,fargs,arglist;
  338.  
  339.     /* get the function symbol and formal argument list */
  340.     xlsave1(arglist);
  341.     sym = xlgasymbol();
  342.     fargs = xlgalist();
  343.     arglist = makearglist(xlargc,xlargv);
  344.  
  345.     /* make the symbol point to a new function definition */
  346.     xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
  347.  
  348.     /* restore the stack and return the function symbol */
  349.     xlpop();
  350.     return (sym);
  351. }
  352.  
  353. /* xdefmacro - special form 'defmacro' */
  354. LVAL xdefmacro()
  355. {
  356.     LVAL sym,fargs,arglist;
  357.  
  358.     /* get the function symbol and formal argument list */
  359.     xlsave1(arglist);
  360.     sym = xlgasymbol();
  361.     fargs = xlgalist();
  362.     arglist = makearglist(xlargc,xlargv);
  363.  
  364.     /* make the symbol point to a new function definition */
  365.     xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
  366.  
  367.     /* restore the stack and return the function symbol */
  368.     xlpop();
  369.     return (sym);
  370. }
  371.  
  372. /* xcond - special form 'cond' */
  373. LVAL xcond()
  374. {
  375.     LVAL list,val;
  376.  
  377.     /* find a predicate th